ZCFSCHFBC2Ab ;HAC/CR;GETS ALLOWABLE AMOUNTS FOR OP PROC;04/29/99  3:27 PM
 ;;1.0;CHAMPVA SYSTEM;;JULY 4, 1990;Build 2
 ;CPTS #10846*, 11233*, #11736* (DTP,4-23-97)
 ;CPTS #10292*, 7/8/97 *CR*
 ;CPTS #11937*  7/11/97 *CR*
 ;CPTS #6298 7/15/97 *CR*
 ;CPTS #13733 BY DTP (13-FEB-98)*
 ;CPTS #14619 BY JLR*
 ;CPTS #14051 BY JLR (20-JUL-98)*
 ;CPTS #16182 (Y2K) - fixed FN number for prevailing fee global - CHMSPF
 ;CPTS #16336 BY DTP (26-MAR-99)*
 ;CR MC215 JEH 8/21/06 - Modified to accept new CMAC file format
 ;TT DEF004574  JEH 3/25/08 - Remove facility/non-facility calls to global ^IBE(353.1 from CHV routines
 ;TT ENC004843: JEH 2/13/09 - Payment of CPT codes requiring TC or 26 modifier
 ;TT DEF008917  JAK 03/31/10 - Prevailing rate issue on DME - HAC usage of CMS DMEPOS fee schedule on DMEs
 ;DEF009248-03 DPT 4/08/10 edit range of dates for begin and terminal dates,BUG009248-03,04,05
 ;;DEV006421 DRW 06/11/12 - added Hospice Payment requirements to calculate Hospice per diem rate based on CBSA and 
 ;;type of service (outpatient or inpatient)  GLOBAL -- 741006.03 (CBSA cross walk)
 ;BUG006421-04-07 originally pulling the most recent wage rate.  Wage rate should be date specific not by entry 
 ;order.  DRW 01/04/13.
 ;DEF016763 DPT 4/28/14 - REJECT 196 IF DOS IS OUTSIDE DATE RANGE FOR CODES
 ;BUG016763 DPT 4/30/14 - CORRECT BUG
 ;DEV004651 2/11/14 EW - FLAG ADDED SO CMAC CALC CAN BE USED FOR WIP REPORT
 ;Warning CHFBC2 and CHFBC2D must have the above change present if this routine has the change
 ;DEV021956 Modify routine to allow for correct wage rate to be applied when 
 ;effective date falls on the same day as Date Of Service.  DRW 10/22/2014
 ;DEV022592 JSE 3/3/15 - FIX SUBSCRIPT ERROR (NEXT+11)
 ;DEV025633 RFE 6/30/16 Correct subscript error in GETMOD
 ;nsd I18439016FY18 - dpt 1/24/18
 ;CPE001-002 PL-ZIP 05/24/2017 GEF
 ;
 S CHMPF=0,CHMPFD="",HOSPAMT=0 K ALLOW
 S CHADOS=$P(REC0,"^",8) G PF:CHADOS<2921001
 S VI=$P(REC0,"^",3) Q:VI=""
 ;I $D(^CHMVEN(VI,1)) I $P(^(1),"^",16)=1 G END:K2="DME-SUPPLY" ; JAK - 03/31/10 - DEF008917
 G END:$P(REC0,"^",27)=2
 S RECC=@(GLPAY_"CI,""COMMON"")")
 ;
PHP  ; 
 G HOSPCE:CHADOS<2970801
 G HOSPCE:$P(RECC,"^",2)=""                     ;;DEV006421 -- added line tag HOSPCE (orginally, ASC)
 G HOSPCE:$P(^CHMDIC(741002.11,$P(RECC,"^",2),0),"^",1)'="PHP"  ;CHECKING FACILITY TYPE
 G HOSPCE:'$D(^CHMDIC(741013.13,"B",$P(@(GLPAY_"CI,K2,NM,0)"),"^",1)))  ;CHECKING PHP CODES
 ; CPE VENDOR STREAMLINING Replace Provider zip with PL-ZIP gef
 ;I '$D(^CHMVEN(VI,2)) S CHMFQUE=10,CHMMDP=CHMMDP_": VENDOR ZIP MISSING" G END
 ;S VZ=$E($P(^CHMVEN(VI,2),"^",5),1,5)
 ;I VZ="" S CHMFQUE=10,CHMMDP=CHMMDP_": VENDOR ZIP MISSING" G END
 S VZ=$E($P($G(^CHMPAY(CI,"VEN-II")),"^",15),1,5)
 I VZ="" S CHMFQUE=10,CHMMDP=CHMMDP_": PL-ZIP MISSING" G END
 S VC=$O(^CHMSMSA("ZIP",VZ,0)) G HOSPCE:'VC
 G HOSPCE:'$D(^CHMSMSA(VC,4,0))
 S PHPDAT=$O(^CHMSMSA(VC,4,"B",CHADOS),-1) G HOSPCE:'PHPDAT
 S PHPI=$O(^CHMSMSA(VC,4,"B",PHPDAT,0)) G HOSPCE:'PHPI
 G HOSPCE:'$D(^CHMSMSA(VC,4,PHPI,0))
 S PHPF=$O(^CHMDIC(741013.13,"B",$P(@(GLPAY_"CI,K2,NM,0)"),"^",1),0)) G HOSPCE:'PHPF
 S FDHD=$P(^CHMDIC(741013.13,PHPF,0),"^",2)
 S CHMPF=$P(^CHMSMSA(VC,4,PHPI,0),"^",FDHD)
 G HOSPCE:+CHMPF=0
 S CMAC(NM)=CHMPF
 S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",9)=5
 G END
HOSPCE  ;  DEV006421 incorporating a new payment requirement for hospice payment
 N IEN,NM1,CBSA,CBSAIEN,CBSAIEN1,CBSANM,CBSANM1,CBSAWC,CBSANWA,CBSAWG,CBSAENT,CBSAENT1            ;;DEV006421 new variables added for this section
 G ASC:CHADOS<2970801                                                            ;;this code from here to END is new for DEV006421 - DRW - 06/15/12
 G ASC:$P(RECC,"^",16)'=5               ;;5 indicates outpatient 
 S FLG=0
 I $P(RECC,"^",2)="" G NEXT
 I $P(^CHMDIC(741002.11,$P(RECC,"^",2),0),"^",1)="HPC" S FLG=FLG+1  ;;hospice facility type
NEXT  ;    in order to avoid subscript error if facility type not defined 
 S CHMSP=$P(@(GLPAY_"CI,K2,NM,0)"),"^"),CHMSPC=$P(^CHMSERV(CHMSP,0),"^",1)    ;;CHMSP contains pointer to CHMSERV and CHMSPC is the service code returned from CHMSERV 
 G:(CHMSPC'="X7000")&(CHMSPC'="X7001")&(CHMSPC'="00.00")&(CHMSPC'="00.99") ASC
 ; CPE VENDOR STREAMLINING Replace Provider zip with PL-ZIP gef
 ;I '$D(^CHMVEN(VI,2)) S CHMFQUE=10,CHMMDP=CHMMDP_": VENDOR ZIP MISSING" G END
 ;S VZ=$E($P(^CHMVEN(VI,2),"^",5),1,5) 
 ;I VZ="" S CHMFQUE=10,CHMMDP=CHMMDP_": VENDOR ZIP MISSING" G END 
 S VZ=$E($P($G(^CHMPAY(CI,"VEN-II")),"^",15),1,5)
 I VZ="" S CHMFQUE=10,CHMMDP=CHMMDP_": PL-ZIP MISSING" G END
 S IEN=$O(^CHMDIC(741006.03,"B",VZ,0))   ;;find the IEN for the CBSA crosswalk based on zip
 ;
 ;;DEV022592 JSE 3/3/15 WAGE RATE NEVER SET CORRECTLY B/C NM1 WAS NEVER SET TO THE CORRECT DIC LOOKUP                 
 ;;                     COMMENT OUT HOW NM1 WAS ORIGINALY SET & THE ATTEMPTED FIX FROM DEV021956 (BELOW)
 ;S NM1=$O(^CHMDIC(741006.03,IEN,1,CHADOS),-1)                              ;; ORIG CODE INCORRECT, CAUSING SUBSCRIPT ERRS
 ;CHECKDT; IF DOS IS NOT CHECKED, THE IEN ABOVE MAY NOT BE THE CORRECT CBSA ;; DEV021956 DRW 11/06/2014 
 ;S EFFDT=$P(^CHMDIC(741006.03,IEN,1,NM1,0),"^",1)                          ;; DEV021956 DRW 11/06/2014          
 ;I CHADOS<EFFDT S NM1=NM1-1 G CHECKDT     ;;LOOP THROUGH UNTIL DOS IS NO LONGER LESS THAN EFFECTIVE DATE   
 ;
 ;;DEV022592 JSE - NEW LOGIC(BELOW) CORRECTLY SETS NM1. THIS LOGIC REPLACE THE LOGIC ABOVE.
 I $D(^CHMDIC(741006.03,IEN,1,"B",CHADOS)) S CHADOS2=CHADOS        ;; DEV022592 JSE - IF DOS HAS AN ENTRY USE DOS DATE
 E  S CHADOS2=$O(^CHMDIC(741006.03,IEN,1,"B",CHADOS),-1)           ;; DEV022592 JSE - IF NO DOS ENTRY, USE DATE B4 DOS
 I CHADOS2="" S CHADOS2=$O(^CHMDIC(741006.03,IEN,1,"B",0))         ;; DEV022592 JSE - IF DOS IS B4 THE 1ST ENT, SET NM1=1ST ENT
 S NM1=$O(^CHMDIC(741006.03,IEN,1,"B",CHADOS2,""))                 ;; DEV022592 JSE - SET NM1 TO ENTRY# 4 SELECTED DATE
 ;
 S CBSA=$P(^CHMDIC(741006.03,IEN,1,NM1,0),"^",5)
 ;;once the CBSA is found, use the CBSA to find the wage index on global ^CHMDIC(741043
 S CBSAIEN=$O(^CHMDIC(741043,"B",CBSA,0))
 ;S CBSANM=$O(^CHMDIC(741043,CBSAIEN,1,"B",CHADOS),-1)             ;; Find the last entry close to the DOS (reverse order))
 I $D(^CHMDIC(741043,CBSAIEN,1,"B",CHADOS)) S CBSANM=CHADOS        ;; DEV021956 DRW - ADDED IF/ELSE FOR EFFECTIVE DATE
 E  S CBSANM=$O(^CHMDIC(741043,CBSAIEN,1,"B",CHADOS),-1)           ;; DEV021956 Find last entry closest to DOS (rev. order))
 I CBSANM="" S CBSANM=$O(^CHMDIC(741043,CBSAIEN,1,"B",CHADOS))
 S CBSAENT=$O(^CHMDIC(741043,CBSAIEN,1,"B",CBSANM,0))              ;;find the physical location of the entry number
 S CBSAWG=$P(^CHMDIC(741043,CBSAIEN,1,CBSAENT,0),"^",6)            ;;wage index rate for the hospice claim
 ;;once the CBSAWG is found, use the formula rate associated with the service code in
 ;;global ^CHMDIC(741045 to determine the hospice per diem rate
 S CBSAIEN1=$O(^CHMDIC(741045,"B",CHMSPC,0))
 ;S CBSANM1=$O(^CHMDIC(741045,CBSAIEN1,1,"B",CHADOS),-1)
 I $D(^CHMDIC(741045,CBSAIEN1,1,"B",CHADOS)) S CBSANM1=CHADOS      ;;DEV021956 DRW-ADDED IF/ELSE FOR EFFECTIVE DATE
 E  S CBSANM1=$O(^CHMDIC(741045,CBSAIEN1,1,"B",CHADOS),-1)
 I CBSANM1="" S CBSANM1=$O(^CHMDIC(741045,CBSAIEN1,1,"B",CHADOS))
 S CBSAENT1=$O(^CHMDIC(741045,CBSAIEN1,1,"B",CBSANM1,0))           ;;find the entry location of date
 S CBSAWC=$P(^CHMDIC(741045,CBSAIEN1,1,CBSAENT1,0),"^",4)          ;;find the wage component
 S CBSANWA=$P(^CHMDIC(741045,CBSAIEN1,1,CBSAENT1,0),"^",5)         ;;find the non-weighted amount
 S HOSPAMT=(CBSAWC*CBSAWG)+CBSANWA                         ;;multiply wage component by the CBSA index + non-weighted amt
 I CHMSPC="X7001" D
 . S HOSPAMT=HOSPAMT/24                                    ;;divide by the number of hours in one day to get daily rate
 S HOSPAMT=$FN(HOSPAMT,"",2)                               ;;the $FN function rounds & sets to two decimal places
 S CHMPF=+HOSPAMT
 S CMAC(NM)=CHMPF
 G END
ASC S CHMSP=$P(@(GLPAY_"CI,K2,NM,0)"),"^"),CHMSPC=$P(^CHMSERV(CHMSP,0),"^",1)  ; Subscript error 9/30/05 mlr
 G CMAC:$P(RECC,"^",2)=""
 G CMAC:$P(^CHMDIC(741002.11,$P(RECC,"^",2),0),"^",1)'="ASC"
 ; CPE VENDOR STREAMLINING Replace Provider zip with PL-ZIP gef
 ;I '$D(^CHMVEN(VI,2)) S CHMFQUE=10,CHMMDP=CHMMDP_": VENDOR ZIP MISSING" G END
 G CMAC:$P(^CHMVEN(VI,1),"^",7)="" S CHFAC=$P(^(1),"^",7)
 G CMAC:($P(^CHMDIC(741002.11,CHFAC,0),"^",1)'="ASF")&($P(^CHMDIC(741002.11,CHFAC,0),"^",1)'="ASH")
 G ASC1:'$D(^CHMAGP("B",CHMSPC))
 ; CPE VENDOR STREAMLINING Replace Provider zip with PL-ZIP gef
 ;S VZ=$E($P(^CHMVEN(VI,2),"^",5),1,5)
 ;I VZ="" S CHMFQUE=10,CHMMDP=CHMMDP_": VENDOR ZIP MISSING" G END
 S VZ=$E($P($G(^CHMPAY(CI,"VEN-II")),"^",15),1,5)
 I VZ="" S CHMFQUE=10,CHMMDP=CHMMDP_": PL-ZIP MISSING" G END
 S VC=$O(^CHMDIC(741002.82,"B",VZ,0)) G CMAC:'VC
 S CHLDT=$O(^CHMDIC(741002.82,VC,1,9999999),-1) G CMAC:'CHLDT
 G CMAC:'$D(^CHMDIC(741002.82,VC,1,CHLDT,0)) S CHMSA=$P(^(0),"^",2)
 F JJ=$L(CHMSA):1:3 S CHMSA="0"_CHMSA
 S CHMGPN=0,CHMGPN=$O(^CHMAGP("B",CHMSPC,CHMGPN)) I 'CHMGPN D  ;nsd I18439016FY18 - dpt 
   .I $P(^CHMDIC(741002.11,CHFAC,0),"^",1)="ASF" G ASC2  ;nsd I18439016FY18 - dpt 
   .G CMAC ;:'CHMGPN  ;nsd I18439016FY18 - dpt 
 ;I '$D(^CHMAGP(CHMGPN,1,(CHADOS+1))) I $P(^CHMDIC(741002.11,CHFAC,0),"^",1)="ASF"  G ASC2  
 ;I '$D(^CHMAGP(CHMGPN,1,(CHADOS+1))) I $P(^CHMDIC(741002.11,CHFAC,0),"^",1)'="ASF" G CMAC 
 ;I $D(^CHMAGP(CHMGPN,1,(CHADOS+1))) S CHGRDT=$O(^CHMAGP(CHMGPN,1,(CHADOS+1)),-1) I CHGRDT="" D
 ;  .I $P(^CHMDIC(741002.11,CHFAC,0),"^",1)="ASF" G ASC2 
 ;  .I $P(^CHMDIC(741002.11,CHFAC,0),"^",1)'="ASF" G CMAC  ;nsd I18439016FY18 - dpt
 S CHGRDT=$O(^CHMAGP(CHMGPN,1,9999999),-1) 
 I CHADOS<CHGRDT  I $P(^CHMDIC(741002.11,CHFAC,0),"^",1)="ASF" G ASC2  ;;nsd I18439016FY18 - dpt DEF016763 DPT 3/28/11 DEV009248-03
 I CHADOS<CHGRDT  I $P(^CHMDIC(741002.11,CHFAC,0),"^",1)'="ASF" G CMAC ;TEST DPT
 G CMAC:'$D(^CHMAGP(CHMGPN,1,CHGRDT,0)) S CHGRP=+$P(^(0),"^",2)
 S CHGRP=+$P(^CHMAGP(CHMGPN,1,CHGRDT,0),"^",2) ;DPT 8/18/10 BUG009248-03
 S CHLEDT=+$P(^CHMAGP(CHMGPN,1,CHGRDT,0),"^",3) ;BUG016763-03-01 DPT 8/18/10
 I CHLEDT'=0,CHADOS>CHLEDT D  ;;nsd I18439016FY18 - dpt
  .I $P(^CHMDIC(741002.11,CHFAC,0),"^",1)="ASF"  G ASC2  ;;nsd I18439016FY18 - dpt DPT 3/28/11BUG009248-05
  .G CMAC ;;nsd I18439016FY18 - dpt
 S CHMMPN=0,CHMMPN=$O(^CHMART("B",CHMSA,CHMMPN)) G CMAC:'CHMMPN
 S CHMSDT=$O(^CHMART(CHMMPN,1,(CHADOS+1)),-1) G ASC1:'CHMSDT ; DPT 3/28/11  BUG009248-05
 G CMAC:'$D(^CHMART(CHMMPN,1,CHMSDT,100,CHGRP,0)) S CHMPF=+$P(^(0),"^",1)
 G CMAC:+CHMPF=0
 S CHMSEDT=+$P(^CHMART(CHMMPN,1,CHMSDT,0),"^",2) ;DPT 8/18/10
 I CHMSEDT'=0,CHADOS>CHMSEDT  
   .I $P(^CHMDIC(741002.11,CHFAC,0),"^",1)="ASF" G ASC2  ; ;nsd I18439016FY18 - dpt DPT 3/28/11 DEV009248-03
   .G CMAC  ;nsd I18439016FY18 - dpt
 S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",9)=3
 ;I WRT=1 S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",9)=3  ;DEV004651 2/11/14 EW TEST FOR WRITE FLAG
 S CMAC(NM)=CHMPF
 S $P(@(GLPAY_"CI,""COMMON"")"),"^",16)=9
 ;I WRT=1 S $P(@(GLPAY_"CI,""COMMON"")"),"^",16)=9  ;DEV004651 2/11/14 EW TEST FOR WRITE FLAG
 G END
ASC1 S CHMPF=+$P(@(GLPAY_"CI,K2,NM,0)"),"^",2),CMAC(NM)=CHMPF
 S $P(@(GLPAY_"CI,""COMMON"")"),"^",16)=9
 ;I WRT=1 S $P(@(GLPAY_"CI,""COMMON"")"),"^",16)=9  ;DEV004651 2/11/14 EW TEST FOR WRITE FLAG
 G END
ASC2 S CHMPF=0,CMAC(NM)=0,REA=196,$P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",2)=REA G END  ;DEF016763 DPT
CMAC I VI="" S CHMFQUE=10,CHMMDP=CHMMDP_": VENDOR ID MISSING" G END
 G PF:'$D(^CHMVEN(VI,41)) S CHCLS="" D  G PF:CHCLS=""
 .S CMJ=$O(^CHMVEN(VI,41,9999999),-1) Q:'CMJ
 .S CHCLS=$P(^CHMVEN(VI,41,CMJ,0),"^",3)
 G PF:"1^2^3"'[CHCLS S CHMSP=$P(@(GLPAY_"CI,K2,NM,0)"),"^")
 S CHMSPC=$P(^CHMSERV(CHMSP,0),"^",1)
 ;CPE VENDOR STREAMLINING replace Provider Zip w/ PL-ZIP gef
 ;I '$D(^CHMVEN(VI,2)) S VZ="" G C0
 ;S VZ=$E($P(^CHMVEN(VI,2),"^",5),1,5)
 S VZ=$E($P($G(^CHMPAY(CI,"VEN-II")),"^",15),1,5)
C0 I VZ="" S CHMFQUE=10,CHMMDP=CHMMDP_": PL-ZIP MISSING" G END
 S VC=$O(^CHMDIC(741002.4,"B",VZ,0))
 G PF:VC=""
 S CHLDT=9999999-CHADOS-1
C1 S CHLDT=$O(^CHMDIC(741002.4,VC,1,CHLDT)) G PF:CHLDT'?7N
 G PF:'$D(^CHMDIC(741002.4,VC,1,CHLDT,0)) S CHLOC=$P(^(0),"^",2)
 S CHMSPN=$O(^CHMCPF("B",CHMSPC,0)) G PF:'CHMSPN S CHX=0
C2 S CHX=$O(^CHMCPF(CHMSPN,CHX)) G C1:'CHX
 G:CHX+8>1000 C1
 G:CHX+8>CHLOC C22
 G C2
C22 S CHCMDT=9999999-CHADOS-1
C3 S CHCMDT=$O(^CHMCPF(CHMSPN,CHX,CHCMDT)) G PF:CHCMDT'?7N
 G PF:'$D(^CHMCPF(CHMSPN,CHX,CHCMDT,0))
 S CHLNM=CHLOC#8 S:CHLOC#8=0 CHLNM=8
 S CHMREC=$P(^CHMCPF(CHMSPN,CHX,CHCMDT,0),"^",2)
 S CHPNM=$P(CHMREC,",",CHLNM)
 D:CHADOS>3070131 GETCLP   ; JEH 2/1/07  CUT-OVER DATE (2/1/07) TO NEW CMAC FORMAT
 S CHMPF=$P(CHPNM,";",CHCLS),MOD=""
 I K2="OPT-PROC" D      ;JEH 2/13/09  TT ENC004843
 .S MOD=$$GTMOD^CHFBC2A(CI,K2,NM,CHMSPC)         ;JEH 2/13/09  TT ENC004843  ADDED SUBROUTINE
 ;S:K2="OPT-PROC" MOD=$P(@(GLPAY_"CI,K2,NM,0)"),"^",4)   ;JEH 2/13/09  TT ENC004843
 S:K2="DEN-PROC" MOD=$P(@(GLPAY_"CI,K2,NM,0)"),"^",6)
 D:MOD'=""
 .Q:CHADOS<2970701
 .Q:('$D(^CHMDIC(741002.98,"B",MOD)))&('$D(^CHMDIC(741002.99,"B",MOD)))
 .S FILEPT=$S($D(^CHMDIC(741002.98,"B",MOD)):"741002.98",$D(^CHMDIC(741002.99,"B",MOD)):"741002.99",1:"")
 .Q:FILEPT=""
 .I '$D(^CHMCPF(CHMSPN,CHX,CHCMDT,1)) D  Q        ;PRO/TECH
 ..S REA="",PERC=""
 ..S MODI=$O(^CHMDIC(FILEPT,"B",MOD,0))
 ..I MODI'="" S:$D(^CHMDIC(FILEPT,MODI,0)) REA=$P(^(0),"^",2),PERC=$P(^(0),"^",3)
 ..S CHMPF=CHMPF*PERC
 ..S X1=CI D PROGTYP^CHFCD001
 ..S $P(@(GLPAY_"CI,K1,NM,0)"),"^",2)=REA
 ..;I WRT=1 S $P(@(GLPAY_"CI,K1,NM,0)"),"^",2)=REA  ;DEV004651 2/11/14 EW TEST FOR WRITE FLAG
 ..;S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),U,2)=REA
 .I CHCLS=2&(CHADOS<3070201) D  Q     ;JEH 2/11/07 ADDED 'CHADOS<3070201' DUE TO NEW FORMAT AND CUTOVER DATE
 ..S PERC="",REA=""
 ..S MODI=$O(^CHMDIC(FILEPT,"B",MOD,0))
 ..I MODI'="" S:$D(^CHMDIC(FILEPT,MODI,0)) REA=$P(^(0),"^",2),PERC=$P(^(0),"^",3)
 ..S CHMPF=CHMPF*PERC
 ..S X1=CI D PROGTYP^CHFCD001
 ..S $P(@(GLPAY_"CI,K1,NM,0)"),"^",2)=REA
 ..;I WRT=1 S $P(@(GLPAY_"CI,K1,NM,0)"),"^",2)=REA  ;DEV004651 2/11/14 EW TEST FOR WRITE FLAG
 ..;S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),U,2)=REA 
 .S CHMREC1=$P(^CHMCPF(CHMSPN,CHX,CHCMDT,1),"^",2)
 .S CHPNM1=$P(CHMREC1,",",CHLNM)
 .;S:FILEPT=741002.98 PT1=CHCLS                      ;CHAMPVA PROF COMPONENT MODIFIERS
 .;S:FILEPT=741002.99 PT1=$S(CHCLS=1:2,CHCLS=3:4)    ;CHAMPVA TECH COMPONENT MODIFIERS
 .I FILEPT=741002.98 D                  ;CHAMPVA PROF. COMPONENT MODFIERS   ;JEH 2/11/07 ADDED FOR NEW FORMAT AND CUTOVER DATE
 ..I CHADOS<3070201 D
 ...S PT1=CHCLS
 ..E  D
 ...S PT1=$S(CHCLS=1:1,CHCLS=2:1,CHCLS=3:3,CHCLS=4:3)
 .I FILEPT=741002.99 D                  ;CHAMPVA TECH COMPONENT MODIFIERS   ;JEH 2/11/07 ADDED FOR NEW FORMAT AND CUTOVER DATE
 ..I CHADOS<3070201 D
 ...S PT1=$S(CHCLS=1:2,CHCLS=3:4)
 ..E  D
 ...S PT1=$S(CHCLS=1:2,CHCLS=2:2,CHCLS=3:4,CHCLS=4:4)
 .S CHMPF=$P(CHPNM1,";",PT1)
 .S REA=""
 .S MODI=$O(^CHMDIC(FILEPT,"B",MOD,0))
 .I MODI'="" S:$D(^CHMDIC(FILEPT,MODI,0)) REA=$P(^(0),"^",2)
 .S X1=CI D PROGTYP^CHFCD001
 .S $P(@(GLPAY_"CI,K1,NM,0)"),"^",2)=REA
 .;I WRT=1 S $P(@(GLPAY_"CI,K1,NM,0)"),"^",2)=REA  ;DEV004651 2/11/14 EW TEST FOR WRITE FLAG
 .;S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),U,2)=REA   
 G PF:+CHMPF=0
 S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",9)=1
 ;I WRT=1 S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",9)=1  ;DEV004651 2/11/14 EW TEST FOR WRITE FLAG
 S CMAC(NM)=CHMPF
 G END
PF S CHMPF=0,CHMDOS=$P(REC0,"^",8),CHMRDT=9999999-CHMDOS,CHMRSD=CHMRDT-1
 ; Y2K fix
 ;S YR=$E(CHMDOS,2,3) I $E(YR,2)="0" S YR=$E(YR,1)
 ;S FN="741012."_YR
 S YR=$E(CHMDOS,1,3)
 S FN=$$FNSET^CHFBC2A(CHMDOS)
 ;
 S CHMSPC=$P(@(GLPAY_"CI,K2,NM,0)"),"^")
 S VI=$P(REC0,"^",3)
 I VI="" S CHMFQUE=10,CHMMDP=CHMMDP_": VENDOR ID MISSING" G END
 ;CPE VENDOR STREAMLINING replace Provider Zip w/ PL-ZIP gef
 ;I '$D(^CHMVEN(VI,2)) S VZ="" G A0
 ;S VZ=$E($P(^CHMVEN(VI,2),"^",5),1,5)
 S VZ=$E($P($G(^CHMPAY(CI,"VEN-II")),"^",15),1,5)
A0 I VZ="" S CHMFQUE=10,CHMMDP=CHMMDP_": PL-ZIP MISSING" G END
 S VST=$P(^(2),"^",4)
 I VST="" S CHMFQUE=10,CHMMDP=CHMMDP_": VENDOR STATE MISSING " G END
 S VC=$O(^CHMSMSA("ZIP",VZ,VST,0))
 I VC="" S CHMFQUE=10,CHMMDP=CHMMDP_": PL-ZIP UNKNOWN OR INCOMPATIBLE WITH STATE" G END
 S CHMSPN=$O(^CHMSPF(FN,"B",CHMSPC,0)) G:CHMSPN="" END
 I $D(^CHMSPF(FN,CHMSPN,"DEL")),$P(^("DEL"),"^",1)=1 G END
 S CHSMDT=$O(^CHMSMSA(VST,1,VC,3,CHMRSD))
 I CHSMDT'?1N.N D GSTSM G A1
 S CHMSNUM=$P(^CHMSMSA(VST,1,VC,3,CHSMDT,0),"^",2)
 I (CHMSNUM=0)!(CHMSNUM="") D GSTSM G A1
 S PF=$S(((CHMSNUM'>20)&(CHMSNUM>0)):1,((CHMSNUM'>40)&(CHMSNUM>20)):2,((CHMSNUM'>60)&(CHMSNUM>40)):3,((CHMSNUM'>80)&(CHMSNUM>60)):4,((CHMSNUM'>100)&(CHMSNUM>80)):5,1:6)
 I PF=6 D GSTSM G A1
 I CHMSNUM<21,$D(^CHMSPF(FN,CHMSPN,PF)) S:$D(^CHMSPF(FN,CHMSPN,PF)) CHMPFD=$P(^CHMSPF(FN,CHMSPN,PF),",",CHMSNUM) I CHMPFD'="" S CHMPF=+$P(CHMPFD,";",1)
 E  I $D(^CHMSPF(FN,CHMSPN,PF)) S:$D(^CHMSPF(FN,CHMSPN,PF)) CHMPFD=$P(^CHMSPF(FN,CHMSPN,PF),",",(CHMSNUM#(20*($S(PF=1:1,PF=2:1,PF=3:2,PF=4:3,PF=5:4,1:1))))) I CHMPFD'="" S CHMPF=+$P(CHMPFD,";",1)
 I CHMPF=0 D GSTSM:YR>293 G END:YR<294 G END:CHMPF=0
 S MOD=""
 I K2="OPT-PROC" D      ;JEH 2/13/09  TT ENC004843
 .S TMPSPC=$P(^CHMSERV(CHMSPC,0),"^",1)   ;GET CODE
 .S MOD=$$GTMOD^CHFBC2A(CI,K2,NM,TMPSPC)         ;JEH 2/13/09  TT ENC004843  ADDED SUBROUTINE
 ;S:K2="OPT-PROC" MOD=$P(@(GLPAY_"CI,K2,NM,0)"),"^",4)   ;JEH 2/13/09  TT ENC004843
 S:K2="DEN-PROC" MOD=$P(@(GLPAY_"CI,K2,NM,0)"),"^",6)
 D:MOD'=""
 .Q:CHADOS<2970701
 .Q:('$D(^CHMDIC(741002.98,"B",MOD)))&('$D(^CHMDIC(741002.99,"B",MOD)))
 .S FILEPT=$S($D(^CHMDIC(741002.98,"B",MOD)):"741002.98",$D(^CHMDIC(741002.99,"B",MOD)):"741002.99",1:"")
 .Q:FILEPT=""
 .S PERC="",REA=""
 .S MODI=$O(^CHMDIC(FILEPT,"B",MOD,0))
 .I MODI'="" S:$D(^CHMDIC(FILEPT,MODI,0)) REA=$P(^(0),"^",2),PERC=$P(^(0),"^",3)
 .S CHMPF=CHMPF*PERC
 .S X1=CI D PROGTYP^CHFCD001
 .S $P(@(GLPAY_"CI,K1,NM,0)"),"^",2)=REA
 .;I WRT=1 S $P(@(GLPAY_"CI,K1,NM,0)"),"^",2)=REA  ;DEV004651 2/11/14 EW TEST FOR WRITE FLAG
 .;S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),U,2)=REA
A1 ;I WRT=1 S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",9)=2  ;DEV004651 2/11/14 EW TEST FOR WRITE FLAG
 S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",9)=2
 S CMAC(NM)=CHMPF
END I (K2="DME-SUPPLY")!(K2="OPT-PROC") D
 .Q:$P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",9)=196  ;DEF016763 DPT
 .Q:$P(@(GLPAY_"CI,K2,NM,0)"),"^",5)=""
 .S CHMPF=$P(^(0),"^",5),CMAC(NM)=CHMPF
 .S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",9)=4
 .;I WRT=1 S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",9)=4  ;DEV004651 2/11/14 EW TEST FOR WRITE FLAG
 .S ALLOW=1
 I K2="DEN-PROC" D
 .Q:$P(@(GLPAY_"CI,K2,NM,0)"),"^",7)=""
 .S CHMPF=$P(^(0),"^",7),CMAC(NM)=CHMPF
 .S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",9)=4
 .;I WRT=1 S $P(@(GLPAY_"CI,""RULE-PROC"",NM,0)"),"^",9)=4  ;DEV004651 2/11/14 EW TEST FOR WRITE FLAG
 .S ALLOW=1
 K CHMPFD,CHMSPN,CHMSNUM,CHSMDT,VST,VC,VI,VZ,CHMSP,CHMSPC,CHLDT
 K CHMSA,CHMGPN,CHGRDT,CHMMPN,CHMSDT,CHGRP,CHFAC,HOSPAMT Q
GSTSM I VST>40 I $D(^CHMSPF(FN,CHMSPN,0)) S:$D(^CHMSPF(FN,CHMSPN,103)) CHMPFD=$P(^CHMSPF(FN,CHMSPN,103),",",VST-40) I $G(CHMPFD)'="" S CHMPF=+$P(CHMPFD,";",1) Q   ;SKD 1-10-07; I CHMPFD'=""
 I (VST>20)&(VST'>40) I $D(^CHMSPF(FN,CHMSPN,0)) S:$D(^CHMSPF(FN,CHMSPN,102)) CHMPFD=$P(^CHMSPF(FN,CHMSPN,102),",",VST-20) I $G(CHMPFD)'="" S CHMPF=+$P(CHMPFD,";",1) Q   ;SKD 1-10-07; I CHMPFD'=""
 I (VST>0)&(VST'>20) I $D(^CHMSPF(FN,CHMSPN,0)) S:$D(^CHMSPF(FN,CHMSPN,101)) CHMPFD=$P(^CHMSPF(FN,CHMSPN,101),",",VST) I $G(CHMPFD)'="" S CHMPF=+$P(CHMPFD,";",1) Q    ;SKD 1-10-07; I CHMPFD'=""
 Q
GETCLP ;DETERMINE CMAC RATE POSITION
 Q:$D(^CHMSERV(CHMSP,4))    ;QUIT IF ANETHESIA CODE    ; JEH 12/5/06
 S CHMFAC=0   ; Set default to Non-facility
 S CHMPOS=99  ; Set default to Other location
 S PTR=""  ;AEB 4/17/2007  
 S:$D(@(GLPAY_"CI,""COMMON"")")) I=$P(@(GLPAY_"CI,""COMMON"")"),"^",2)
 ;I I I $D(^CHMDIC(741002.11,I,0)) S PTR=$P(^(0),"^",5)   ;JEH 3/25/08
 ;I PTR I $D(^IBE(353.1,PTR,0)) S CHMFAC=$P(^(0),"^",4)   ;GET FACILITY TYPE   ;JEH 3/25/08
 I I I $D(^CHMDIC(741002.11,I,0)) S CHMFAC=$P(^(0),"^",7)   ;JEH 3/25/08
 S CHCLS=CHCLS+CHMFAC
 Q
FNSET(FMDT) ;Sets the correct FN for prevailing fee global (CHMSPF)
 ; FMDT must be a fileman date (2990101) or at least the
 ;      first three positions of the fileman dt (299)
 ; Y2K - This was added to make global Y2K compliant (FN was 741012.99
 ;       and now is 741012.299).  Trailing zeros will be truncated in 
 ;       order to be compatiable with Fileman.
 ; 
 N X,Y
 S Y=""
 I $L(FMDT)>2 D
 .S X=$E(FMDT,1,3)
 .I $E(X,3)=0 S X=$E(X,1,2) D
 ..I $E(X,2)=0 S X=$E(X,1)
 .S Y="741012."_X
 Q Y
GTMOD(GCI,GK2,GNM,GCHMSPC)  ;SUBROUTINE TO DETERMINE/GET MODIFIERS FOR OUTPATIENT CLAIMS
 ;JEH 4/13/10 ENC004843
 ;GCI = CLAIM POINTER
 ;GK2 = GLOBAL NODE INDICATOR - "OPT-PROC"
 ;GNM = J VALUE FROM PAY FILE
 N MOD,TOB,POS,TOC,CHMREC,CHPNM,CHMREC1,CHPNM1
 S MOD="" S MOD=$P(@(GLPAY_"GCI,GK2,GNM,0)"),"^",4)
 Q:'$D(^CHMCPF("B",GCHMSPC)) MOD   ;QUIT IF CODE NOT IN CMAC GLOBAL
 Q:MOD=4!(MOD=83) MOD  ;4=26/83=TC
 S TOC="" S TOC=$P(@(GLPAY_"GCI,0)"),"^",7)      ;TYPE OF CLAIM 2=OUTPATIENT
 Q:TOC'=2 MOD
 Q:CHCMDT="" MOD                         ; RFE 6/30/16 DEV025633         
 I (GCHMSPC>=70000)&(GCHMSPC<=90000) {
    S TOB=""   ;BILL TYPE BILL (013x-HOSP OUTPATIENT, 014x-HOSP OTHER PART B)
    S:$D(@(GLPAY_"GCI,7)")) TOB=$P(@(GLPAY_"GCI,7)"),"^",6)
    S POS=0 S POS=$P(@(GLPAY_"GCI,""COMMON"")"),"^",2)  ;PLACE OF SERVICE
    I TOB'="" {
        I ("12,13,14,22,23,83"[$E(TOB,1,2))&(POS=2) {      ;BILL CODE TYPE  013x-Hospital Outpatient/014x-Hospital Other Part B
            I $D(^CHMCPF(CHMSPN,CHX,CHCMDT,0)) {
                S CHMREC=$P(^CHMCPF(CHMSPN,CHX,CHCMDT,0),"^",2)   ;TECH
                S CHPNM=$P(CHMREC,",",CHLNM)
                I $P(CHPNM,";",4)'=""&($P(CHPNM,";",4)>0) S MOD=83    ;83=TC
            }
        }
    }
    I (TOB=""&(POS=2))!(POS=86) {   ;2-OP,86-IPP
        I $D(^CHMCPF(CHMSPN,CHX,CHCMDT,1)) {
            S CHMREC1=$P(^CHMCPF(CHMSPN,CHX,CHCMDT,1),"^",2)   ;PRO
            S CHPNM1=$P(CHMREC1,",",CHLNM)
            I $P(CHPNM1,";",3)'=""&($P(CHPNM1,";",3)>0) S MOD=4    ;4=26
        }
    }
 }
 Q MOD